home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / xm / pulldown-menu < prev    next >
Encoding:
Text File  |  1992-10-01  |  1.5 KB  |  51 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; Pulldown menu demo
  4.  
  5. (require 'motif)
  6. (load-widgets shell row-column cascade-button push-button label separator)
  7. (load 'menu-stuff)
  8.  
  9. (define top (application-initialize 'pulldown))
  10.  
  11. (define menu-bar (create-menu-bar top))
  12.  
  13. ;;; Create pulldown menu pane with 3 push buttons and a sub-menu
  14.  
  15. (define menu-1 (create-pulldown-menu menu-bar))
  16.  
  17. (menu-add-button! menu-1 'label-string "item 1")
  18. (menu-add-button! menu-1 'label-string "item 2")
  19. (menu-add-button! menu-1 'label-string "item 3")
  20. (menu-add-separator! menu-1)
  21.  
  22. (create-cascade-pulldown menu-bar menu-1 'mnemonic #\m 'label-string "menu-1")
  23.  
  24. ;;; Create the sub-menu:
  25.  
  26. (define sub-menu (create-pulldown-menu menu-1))
  27.  
  28. (menu-add-label! sub-menu 'label-string "sub-menu")
  29. (menu-add-separator! sub-menu)
  30. (menu-add-button! sub-menu 'label-string "item 1")
  31. (menu-add-button! sub-menu 'label-string "item 2")
  32. (menu-add-button! sub-menu 'label-string "item 3")
  33.  
  34. (create-cascade-pulldown menu-1 sub-menu 'label-string "sub-menu")
  35.  
  36. ;;; Create second pulldown menu width a quit button)
  37.  
  38. (define menu-2 (create-pulldown-menu menu-bar))
  39.  
  40. (menu-add-button! menu-2 'label-string "item 1")
  41. (menu-add-button! menu-2 'label-string "item 2")
  42. (menu-add-button! menu-2 'label-string "item 3" 'sensitive #f)
  43. (menu-add-button! menu-2 'label-string "item 4")
  44. (menu-add-button! menu-2 'label-string "quit" 'mnemonic #\q
  45.   'activate-callback (list (lambda args (print args) (exit))))
  46.  
  47. (create-cascade-pulldown menu-bar menu-2 'label-string "menu-2")
  48.  
  49. (realize-widget top)
  50. (context-main-loop (widget-context top))
  51.